home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / swags-z / sorting.swg / 0051_TV Sorting unit.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-24  |  20KB  |  511 lines
  1. {*******************************************************************}
  2. {                                                                   }
  3. {     WVS Software Company                                          }
  4. {     Turbo Pascal Sorting Unit for TCollections                    }
  5. {     Usage Fee: None, public domain                                }
  6. {     Version: 1.0                                                  }
  7. {     Release Date: 6/27/93                                         }
  8. {                                                                   }
  9. {     Programmer: Brad Williams                                     }
  10. {     E-mail    : bwilliams@marvin.ag.uidaho.edu                    }
  11. {     US Mail   : 1008 E. 7th                                       }
  12. {                 Moscow, Idaho 83843                               }
  13. {                                                                   }
  14. {*******************************************************************}
  15. {                                                                   }
  16. {  This unit contains objects for performing various types of       }
  17. {  sorts.  To use any of the sorting methods, simply pass them a    }
  18. {  collection and a compare or test function.  You can write your   }
  19. {  programs to accept a TSortProcedure/TSearchFunction as a         }
  20. {  parameter to any function or procedure and use whichever type    }
  21. {  of sort/search you require at that point in your program.  The   }
  22. {  search and sort methods accept pointers to compare and test      }
  23. {  functions so that the same functions can be used for iterative   }
  24. {  procedures/functions in a TSortedCollection.                     }
  25. {                                                                   }
  26. {*******************************************************************}
  27. UNIT TVSorts;
  28. {****************************************************************************}
  29.                                  INTERFACE
  30. {****************************************************************************}
  31. USES Objects;
  32.  
  33. TYPE
  34.   TCompareFunction = FUNCTION (Item1, Item2 : Pointer) : Integer;
  35.     { A TCompareFunction must return:   }
  36.     {   1  if the Item1 > Item2         }
  37.     {   0  if the Item1 = Item2         }
  38.     {  -1  if the Item1 < Item2         }
  39.  
  40.   TSortProcedure = PROCEDURE  (ACollection : PCollection;
  41.                                Compare : TCompareFunction);
  42.  
  43.   { Sort Procedures }
  44. PROCEDURE BinaryInsertionSort (ACollection : PCollection;
  45.                                Compare : TCompareFunction);
  46. PROCEDURE BubbleSort (ACollection : PCollection; Compare : TCompareFunction);
  47. PROCEDURE CombSort   (ACollection : PCollection; Compare : TCompareFunction);
  48. PROCEDURE HeapSort   (ACollection : PCollection; Compare : TCompareFunction);
  49. PROCEDURE QuickSort  (ACollection : PCollection; Compare : TCompareFunction);
  50. PROCEDURE QuickSortNonRecursive (ACollection : PCollection;
  51.                                  Compare : TCompareFunction);
  52. PROCEDURE ShakerSort (ACollection : PCollection; Compare : TCompareFunction);
  53. PROCEDURE ShellSort  (ACollection : PCollection; Compare : TCompareFunction);
  54. PROCEDURE StraightInsertionSort (ACollection : PCollection;
  55.                                  Compare : TCompareFunction);
  56. PROCEDURE StraightSelectionSort (ACollection : PCollection;
  57.                                  Compare : TCompareFunction);
  58. PROCEDURE TreeSort (ACollection : PCollection; Compare : TCompareFunction);
  59.  
  60.  
  61.   { Compare Procedures - Must write your own Compare for pointer variables. }
  62.   { This allows one sort routine to be used on any array.                   }
  63. FUNCTION  CompareChars    (Item1, Item2 : Pointer) : Integer; FAR;
  64. FUNCTION  CompareInts     (Item1, Item2 : Pointer) : Integer; FAR;
  65. FUNCTION  CompareLongInts (Item1, Item2 : Pointer) : Integer; FAR;
  66. FUNCTION  CompareReals    (Item1, Item2 : Pointer) : Integer; FAR;
  67. FUNCTION  CompareStrs     (Item1, Item2 : Pointer) : Integer; FAR;
  68.  
  69. {****************************************************************************}
  70.                                IMPLEMENTATION
  71. {****************************************************************************}
  72. {                                                                            }
  73. {                      Local Procedures and Functions                        }
  74. {                                                                            }
  75. {****************************************************************************}
  76. PROCEDURE Swap (ACollection : PCollection; A, B : Integer);
  77. VAR Item : Pointer;
  78. BEGIN
  79.   Item := ACollection^.At(A);
  80.   ACollection^.AtPut(A,ACollection^.At(B));
  81.   ACollection^.AtPut(B,Item);
  82. END;
  83. {****************************************************************************}
  84. {                                                                            }
  85. {                      Global Procedures and Functions                       }
  86. {                                                                            }
  87. {****************************************************************************}
  88. PROCEDURE BinaryInsertionSort (ACollection : PCollection;
  89.                                Compare : TCompareFunction);
  90. VAR i, j, Middle, Left, Right : LongInt;
  91. BEGIN
  92.   FOR i := 0 TO (ACollection^.Count - 1) DO
  93.       BEGIN
  94.         Left := 0;
  95.         Right := i;
  96.         WHILE Left < Right DO
  97.           BEGIN
  98.             Middle := (Left + Right) DIV 2;
  99.             WITH ACollection^ DO
  100.               IF Compare(At(Middle),At(i)) < 1
  101.                  THEN Left := Middle + 1
  102.                  ELSE Right := Middle;
  103.           END;
  104.         FOR j := i DOWNTO (Right + 1) DO
  105.             Swap(ACollection,j,j-1);
  106.       END;
  107. END;
  108. {****************************************************************************}
  109. PROCEDURE BubbleSort (ACollection : PCollection; Compare : TCompareFunction);
  110. VAR i, j : Integer;
  111. BEGIN
  112.   WITH ACollection^ DO
  113.     FOR i := 1 TO (Count - 1) DO
  114.         FOR j := (Count - 1) DOWNTO i DO
  115.         IF Compare(At(j-1),At(j)) = 1
  116.            THEN Swap(ACollection,j,j-1);
  117. END;
  118. {****************************************************************************}
  119. PROCEDURE CombSort (ACollection : PCollection; Compare : TCompareFunction);
  120.   { The combsort is an optimised version of the bubble sort. It uses a }
  121.   { decreasing gap in order to compare values of more than one element }
  122.   { apart.  By decreasing the gap the array is gradually "combed" into }
  123.   { order ... like combing your hair. First you get rid of the large   }
  124.   { tangles, then the smaller ones ...                                 }
  125.   {                                                                    }
  126.   { There are a few particular things about the combsort. Firstly, the }
  127.   { optimal shrink factor is 1.3 (worked out through a process of      }
  128.   { exhaustion by the guys at BYTE magazine). Secondly, by never       }
  129.   { having a gap of 9 or 10, but always using 11, the sort is faster.  }
  130.   {                                                                    }
  131.   { This sort approximates an n log n sort - it's faster than any      }
  132.   { other sort I've seen except the quicksort (and it beats that too   }
  133.   { sometimes ... have you ever seen a quicksort become an (n-1)^2     }
  134.   { sort ... ?). The combsort does not slow down under *any*           }
  135.   { circumstances. In fact, on partially sorted lists (including       }
  136.   { *reverse* sorted lists) it speeds up.                              }
  137.   {                                                                    }
  138.   { More information in the April 1991 BYTE magazine.                  }
  139. CONST ShrinkFactor = 1.3;
  140. VAR Gap, i   : LongInt;
  141.     Finished : Boolean;
  142. BEGIN
  143.   Gap := Round((ACollection^.Count-1)/ShrinkFactor);
  144.   WITH ACollection^ DO
  145.     REPEAT
  146.       Finished := TRUE;
  147.       Gap := Trunc(Gap/ShrinkFactor);
  148.       IF Gap < 1
  149.          THEN Gap := 1
  150.          ELSE IF ((Gap = 9) OR (Gap = 10))
  151.                  THEN Gap := 11;
  152.       FOR i := 0 TO ((Count - 1) - Gap) DO
  153.           IF Compare(At(i),At(i+Gap)) = 1
  154.              THEN BEGIN
  155.                     Swap(ACollection,i,i+gap);
  156.                     Finished := False;
  157.                   END;
  158.   UNTIL ((Gap = 1) AND Finished);
  159. END;
  160. {****************************************************************************}
  161. PROCEDURE HeapSort (ACollection : PCollection; Compare : TCompareFunction);
  162.   { Performs best when items are in inverse order. }
  163. VAR L, R : LongInt;
  164.     X : Pointer;
  165.     {*****************************************}
  166.     PROCEDURE Sift;
  167.     VAR i, j : LongInt;
  168.         Label 13;
  169.     BEGIN
  170.       i := L;
  171.       j := 2 * i;
  172.       X := ACollection^.At(i);
  173.       WITH ACollection^ DO
  174.         WHILE j <= R DO
  175.           BEGIN
  176.             IF j < R
  177.                THEN IF Compare(At(j),At(j+1)) = -1
  178.                        THEN Inc(j);
  179.             IF Compare(X,At(j)) >= 0
  180.                THEN GoTo 13;
  181.             AtPut(i,At(j));
  182.             i := j;
  183.             j := 2 * i;
  184.           END;
  185.       13: ACollection^.AtPut(i,X);
  186.     END;
  187.     {*****************************************}
  188. BEGIN
  189.   L := ((ACollection^.Count - 1) DIV 2) + 1;
  190.   R := ACollection^.Count - 1;
  191.   WHILE L > 0 DO
  192.     BEGIN
  193.       Dec(L);
  194.       Sift;
  195.     END;
  196.   WHILE R > 0 DO
  197.     BEGIN
  198.       X := ACollection^.At(1);
  199.       Swap(ACollection,0,R);
  200.       Dec(R);
  201.       Sift;
  202.     END;
  203. END;
  204. {****************************************************************************}
  205. PROCEDURE QuickSort (ACollection : PCollection; Compare : TCompareFunction);
  206.   {****************************************************************}
  207.   PROCEDURE Sort (Left, Right : LongInt);
  208.   VAR i, j  : LongInt;
  209.       X : Pointer;
  210.   BEGIN
  211.     WITH ACollection^ DO
  212.       BEGIN
  213.         i := Left;
  214.         j := Right;
  215.         X := At((Left + Right) DIV 2);
  216.         REPEAT
  217.           WHILE Compare(At(i),X) = -1 DO Inc(i);
  218.           WHILE Compare(X,At(j)) = -1 DO Dec(j);
  219.           IF i <= j
  220.              THEN BEGIN
  221.                     Swap(ACollection,i,j);
  222.                     Inc(i);
  223.                     Dec(j)
  224.                 END;
  225.         UNTIL i > j;
  226.         IF Left < j
  227.            THEN Sort(Left,j);
  228.         IF i < Right
  229.            THEN Sort(i,Right)
  230.       END;
  231.   END;
  232.   {****************************************************************}
  233. BEGIN
  234.   Sort(0,ACollection^.Count-1);
  235. END;
  236. {****************************************************************************}
  237. PROCEDURE QuickSortNonRecursive (ACollection : PCollection;
  238.                                  Compare : TCompareFunction);
  239. CONST m = 12;
  240. VAR i, j, L, R : LongInt;
  241.     x : Pointer;
  242.     s : 0..m;
  243.     Stack : ARRAY[1..m] OF RECORD
  244.                              l, r : LongInt;
  245.                            END;
  246. BEGIN
  247.   s := 1;
  248.   Stack[1].l := 0;
  249.   Stack[1].r := ACollection^.Count - 1;
  250.   WITH ACollection^ DO
  251.     REPEAT
  252.       L := Stack[s].l;
  253.       R := Stack[s].r;
  254.       Dec(S);
  255.       REPEAT
  256.         i := L;
  257.         j := R;
  258.         x := At((L + R) DIV 2);
  259.         REPEAT
  260.           WHILE Compare(x,At(i)) =  1 DO Inc(i);
  261.           WHILE Compare(x,At(j)) = -1 DO Dec(j);
  262.           IF i <= j
  263.              THEN BEGIN
  264.                     Swap(ACollection,i,j);
  265.                     Inc(i);
  266.                     Dec(j);
  267.                   END;
  268.         UNTIL i > j;
  269.         IF i < R
  270.            THEN BEGIN
  271.                   Inc(s);
  272.                   Stack[s].l := i;
  273.                   Stack[s].r := R;
  274.                 END;
  275.         R := j;
  276.       UNTIL L >= R;
  277.     UNTIL s = 0;
  278. END;
  279. {****************************************************************************}
  280. PROCEDURE ShakerSort (ACollection : PCollection; Compare : TCompareFunction);
  281.   { Works for any array and any index range. }
  282. VAR j, k, Left, Right : LongInt;
  283. BEGIN
  284.   Left := 1;
  285.   Right := (ACollection^.Count - 1);
  286.   k := Right;
  287.   WITH ACollection^ DO
  288.     REPEAT
  289.       FOR j := Right DOWNTO Left DO
  290.           IF Compare(At(j-1),At(j)) = 1
  291.              THEN BEGIN
  292.                     Swap(ACollection,j,j-1);
  293.                     k := j;
  294.                   END;
  295.       Left := k + 1;
  296.       FOR j := Left TO Right DO
  297.           IF Compare(At(j-1),At(j)) = 1
  298.              THEN BEGIN
  299.                     Swap(ACollection,j,j-1);
  300.                     k := j;
  301.                   END;
  302.       Right := k - 1;
  303.     UNTIL Left > Right;
  304. END;
  305. {****************************************************************************}
  306. PROCEDURE ShellSort (ACollection : PCollection; Compare : TCompareFunction);
  307. VAR Gap, i, j, k : LongInt;
  308. BEGIN
  309.   Gap := (ACollection^.Count - 1) DIV 2;
  310.   WHILE (Gap > 0) DO
  311.     BEGIN
  312.       FOR i := Gap TO (ACollection^.Count - 1) DO
  313.           BEGIN
  314.             j := i - Gap;
  315.             WHILE (j > -1) DO
  316.               BEGIN
  317.                 k := j + Gap;
  318.                 IF Compare(ACollection^.At(j),ACollection^.At(k)) < 1
  319.                    THEN j := 0
  320.                    ELSE Swap(ACollection,j,k);
  321.                 Dec(j,Gap);
  322.               END;
  323.           END;
  324.       Gap := Gap DIV 2;
  325.     END;
  326. END;
  327. {****************************************************************************}
  328. PROCEDURE StraightInsertionSort (ACollection : PCollection;
  329.                                  Compare : TCompareFunction);
  330. VAR i, j : LongInt;
  331.     X : Pointer;
  332. BEGIN
  333.   WITH ACollection^ DO
  334.     FOR i := 0 TO (Count - 1) DO
  335.       BEGIN
  336.         X := At(i);
  337.         j := i;
  338.         WHILE (j > 0) AND (Compare(X,At(j-1)) = -1) DO
  339.           BEGIN
  340.             AtPut(j,At(j-1));
  341.             Dec(j);
  342.           END;
  343.         AtPut(j,X);
  344.       END;
  345. END;
  346. {****************************************************************************}
  347. PROCEDURE StraightSelectionSort (ACollection : PCollection;
  348.                                  Compare : TCompareFunction);
  349. VAR i, j, k  : LongInt;
  350. BEGIN
  351.   FOR i := 0 TO (ACollection^.Count - 1) DO
  352.       BEGIN
  353.         k := i;
  354.         FOR j := (i + 1) TO (ACollection^.Count - 1) DO
  355.             IF Compare(ACollection^.At(j),ACollection^.At(k)) = -1
  356.                THEN k := j;
  357.         Swap(ACollection,i,k);
  358.       END;
  359. END;
  360. {****************************************************************************}
  361. PROCEDURE TreeSort (ACollection : PCollection; Compare : TCompareFunction);
  362. {after D.Cooke, A.H.Craven, G.M.Clarke: Statistical Computing
  363.  in Pascal, Publisher: Edward Arnold, London 1985 ISBN 0-7131-3545-X }
  364. TYPE PNode    = ^Node;
  365.      Node = RECORD
  366.               Value : Pointer;
  367.               Left  : PNode;
  368.               Right : PNode;
  369.             END;
  370. VAR  Add, Top : PNode;
  371.      i    : LongInt;
  372.     {***********************************************************}
  373.     PROCEDURE MakeTree (VAR Node : PNode);
  374.     BEGIN
  375.       IF Node = NIL
  376.          THEN Node := Add
  377.          ELSE IF Compare(Add^.Value,Node^.Value) = 1
  378.                  THEN MakeTree(Node^.Right)
  379.                  ELSE MakeTree(Node^.Left);
  380.     END;
  381.     {**********************************************************}
  382.      PROCEDURE StripTree (Node : PNode);
  383.      BEGIN
  384.        IF Node <> NIL
  385.           THEN BEGIN
  386.                  StripTree(Node^.Left);
  387.                  ACollection^.AtPut(i,Node^.Value);
  388.                  Inc(i);
  389.                  StripTree(Node^.Right)
  390.                END;
  391.      END;
  392.     {**********************************************************}
  393. BEGIN
  394.   Top := NIL;
  395.   FOR i := 0 TO (ACollection^.Count - 1) DO
  396.     BEGIN
  397.       New(Add);
  398.       Add^.Value := ACollection^.At(i);
  399.       Add^.Left  := NIL;
  400.       Add^.Right := NIL;
  401.       MakeTree(Top)
  402.     END;
  403.     i := 0;
  404.     StripTree(Top)
  405. END;
  406. {****************************************************************************}
  407. {                                                                            }
  408. {                            Compare Procedures                              }
  409. {                                                                            }
  410. {****************************************************************************}
  411. FUNCTION CompareChars (Item1, Item2 : Pointer) : Integer;
  412. BEGIN
  413.   IF Char(Item1^) < Char(Item2^)
  414.      THEN CompareChars := -1
  415.      ELSE CompareChars := Ord(Char(Item1^) <> Char(Item2^));
  416. END;
  417. {*****************************************************************************}
  418. FUNCTION CompareInts (Item1, Item2 : Pointer) : Integer;
  419. BEGIN
  420.   IF Integer(Item1^) < Integer(Item2^)
  421.      THEN CompareInts := -1
  422.      ELSE CompareInts := Ord(Integer(Item1^) <> Integer(Item2^));
  423. END;
  424. {*****************************************************************************}
  425. FUNCTION CompareLongInts (Item1, Item2 : Pointer) : Integer;
  426. BEGIN
  427.   IF LongInt(Item1^) < LongInt(Item2^)
  428.      THEN CompareLongInts := -1
  429.      ELSE CompareLongInts := Ord(LongInt(Item1^) <> LongInt(Item2^));
  430. END;
  431. {*****************************************************************************}
  432. FUNCTION CompareReals (Item1, Item2 : Pointer) : Integer;
  433. BEGIN
  434.   IF Real(Item1^) < Real(Item2^)
  435.      THEN CompareReals := -1
  436.      ELSE CompareReals := Ord(Real(Item1^) <> Real(Item2^));
  437. END;
  438. {*****************************************************************************}
  439. FUNCTION CompareStrs (Item1, Item2 : Pointer) : Integer;
  440. BEGIN
  441.   IF String(Item1^) < String(Item2^)
  442.      THEN CompareStrs := -1
  443.      ELSE CompareStrs := Ord(String(Item1^) <> String(Item2^));
  444. END;
  445. {*****************************************************************************}
  446. BEGIN
  447. END.
  448.  
  449. { -----------------------------------  DEMO PROGRAM ---------------------}
  450.  
  451. PROGRAM Test;
  452. USES Crt, Objects, TVSorts;
  453.  
  454. CONST
  455.   MaxCollectionSize = 10;
  456.  
  457. VAR C : TCollection;
  458.     i, j, k : Integer;
  459.     Ch : ^Char;
  460.  
  461. BEGIN
  462.   Randomize;
  463.   FOR i := 1 TO 11 DO
  464.     BEGIN
  465.         { initialize collection and load with data in reverse order }
  466.       C.Init(MaxCollectionSize,1);
  467.       FOR j := MaxCollectionSize DOWNTO 0 DO
  468.           BEGIN
  469.             k := Random(255);
  470.             WHILE (k < 65) OR (k > 90) DO k := Random(255);
  471.             New(Ch);
  472.             Ch^ := Char(k);
  473.             C.AtInsert(0,Ch);
  474.           END;
  475.         { display unsorted data }
  476.       ClrScr;
  477.       CASE i OF
  478.         1 : WriteLn('Binary Insertion Sort');
  479.         2 : WriteLn('Bubble Sort');
  480.         3 : WriteLn('Comb Sort');
  481.         4 : WriteLn('Heap Sort');
  482.         5 : WriteLn('Quick Sort');
  483.         6 : WriteLn('Non-recursive Quick Sort');
  484.         7 : WriteLn('Shaker Sort');
  485.         8 : WriteLn('Shell Sort');
  486.         9 : WriteLn('Straight Insertion Sort');
  487.        10 : WriteLn('Straight Selection Sort');
  488.        11 : WriteLn('Tree Sort');
  489.       END;
  490.       FOR j := 0 TO (C.Count - 1) DO Write(Char(C.At(j)^):2);
  491.         { sort data }
  492.       CASE i OF
  493.         1 : BinaryInsertionSort(@C,CompareChars);
  494.         2 : BubbleSort(@C,CompareChars);
  495.         3 : CombSort(@C,CompareChars);
  496.         4 : HeapSort(@C,CompareChars);
  497.         5 : QuickSort(@C,CompareChars);
  498.         6 : QuickSortNonRecursive(@C,CompareChars);
  499.         7 : ShakerSort(@C,CompareChars);
  500.         8 : ShellSort(@C,CompareChars);
  501.         9 : StraightInsertionSort(@C,CompareChars);
  502.        10 : StraightSelectionSort(@C,CompareChars);
  503.        11 : TreeSort(@C,CompareChars);
  504.       END;
  505.         { display sorted data }
  506.       WriteLn;
  507.       FOR j := 0 TO (C.Count - 1) DO Write(Char(C.At(j)^):2);
  508.       ReadLn;
  509.         { clear of collection }
  510.     END;
  511. END.